home *** CD-ROM | disk | FTP | other *** search
/ PC-SIG Library 8 / PC-SIG Library CD-ROM (8th Edition) (1990-04).iso / 001_100 / disk0074 / demos.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1983-07-06  |  7.4 KB  |  250 lines
  1. {copyright Software Labs. 1983}
  2. {$include:'b:demos.inc'}
  3. implementation of demosunit;
  4.  
  5. {$include:'b:slib.inc'}      {Screen control routines }
  6. {$include:'b:glib.inc'}      {Graphics       routines }
  7. {$debug-}
  8.  
  9. const
  10.   msgrow = 23;    msgcol = 0;
  11.   inforow = 22; normal = 2; intensity = 15;
  12.   blanks = '                              ';
  13.  
  14. var
  15.   currentpage, currentmode, lastscan : integer;  lastch : char;
  16.  
  17.  
  18.  
  19. {***** column - print a column of numbers for labeling color table }
  20. procedure colnum(row, col, snum, diff, count : integer);
  21. var lastrow : integer;
  22. begin
  23.   lastrow := row+count;
  24.   while row < lastrow do begin
  25.     locate(0, row, col);
  26.     putchar(0,normal, 1, chr(snum+ord('0')));
  27.     snum := snum+diff;
  28.     row := row+1;
  29.   end;
  30. end;  {colnum}
  31.  
  32.  
  33.  
  34.  
  35.  
  36. {***** lstringwrite - write an lstring at the specific position }
  37. procedure lstringwrite(page, row, col, attribute : integer;const ls:lstring);
  38. begin
  39.   locate( page, row, col );
  40.   putlstring(page, attribute, ls);
  41. end;
  42.  
  43.  
  44.  
  45.  
  46. {***** header - print the header for color tables }
  47. procedure header;
  48. begin
  49.   screen( currentmode );                    { new screen }
  50.   lstringwrite(currentpage,24,6,intensity,'(C) Copyright software Labs 1983');
  51.   locate(currentpage, 0,32);
  52.   writeln('mode =',currentmode:1);
  53.   lstringwrite(currentpage,2,0,normal,'Locate a color/attribute(0..255)');
  54.   lstringwrite(currentpage,3,0,normal,' by its row number(the first two digits)'
  55.         );
  56.   lstringwrite(currentpage,4,0,normal,' and its column number(the third digit)')
  57. end; { header }
  58.  
  59.  
  60.  
  61. {***** demosdecimal  display all the colors in two tables indexed by decimals}
  62. procedure demosdecimal;
  63. const zeroto9 = '0123456789'; col = 0; startrow = 5;
  64. var  st[static]: array [ 0 .. 1 ] of string(10);
  65.      row, i,lastrow,sti,color  : integer;
  66. value
  67.   st[0] := '**Software'; st[1] := 'Labs(C)*83';
  68.  
  69. begin
  70.   header;
  71.   lstringwrite(currentpage,0,0,normal,'Color Table(Decimal Index)Mode');
  72.   { the left table color 0 - 129 }
  73.   locate(0, startrow, col+3); putlstring(0,normal,zeroto9);
  74.   colnum(startrow+1,col,0,0,10); colnum(startrow+1,col+1,0,1,10);
  75.   colnum(startrow+11,col,1,0,3); colnum(startrow+11,col+1,0,1,3);
  76.   color := 0;  sti := 1;
  77.   for row := startrow+1 to startrow+1+12 do begin
  78.     locate(0,row,col+3);    if sti = 0 then sti := 1 else sti := 0;
  79.     for i := 1 to 10 do begin
  80.     putchar(0, color, 1,st[sti][i] );
  81.     color := color+1;
  82.     end;
  83.   end;
  84.  
  85.   { right part for 130-256 }
  86.   locate(0, startrow, col+18); putlstring(0,normal,zeroto9);
  87.   colnum(startrow+1,col+15,1,0,7); colnum(startrow+1,col+16,3,1,7);
  88.   colnum(startrow+8,col+15,2,0,6); colnum(startrow+8,col+16,0,1,6);
  89.   sti := 1;
  90.   for row := startrow+1 to startrow+1+12 do begin
  91.     locate(0,row,col+18);   if sti = 0 then sti := 1 else sti := 0;
  92.     for i := 1 to 10 do begin
  93.        if color < 256 then
  94.     putchar(0, color, 1,st[sti][i]);
  95.        color := color+1;
  96.     end;
  97.   end;
  98. end; {demosdecimal }
  99.  
  100.  
  101.  
  102.  
  103.  
  104. {***** demosoctal- display all the character colors by octal indexing }
  105. procedure demosoctal;
  106. const  startcol = 0;
  107.  
  108.   {***** octalcolor - internal procedure for display color for one table }
  109.   procedure octalcolor(col, snum, color : integer);
  110.   const zeroto7 = '01234567';  startrow = 5;
  111.   var row, i, sti : integer;
  112.       st [static] : array[0 .. 1 ] of string(8);
  113.  
  114.   value
  115.      st[0] := 'Software'; st[1] := 'Labs*(C)';
  116.  
  117.   begin
  118.     locate(0, startrow, col+3); putlstring(0,normal,zeroto7);
  119.     colnum(startrow+1,col,snum,0,8); colnum(startrow+1,col+1,0,1,8);
  120.     colnum(startrow+9,col,snum+1,0,8); colnum(startrow+9,col+1,0,1,8);
  121.     sti := 1;
  122.     for row := startrow+1 to startrow+1+15 do begin
  123.       locate(0,row,col+3); if sti = 0 then sti := 1 else sti := 0;
  124.       for i := 1 to 8 do begin
  125.     putchar(0, color, 1,st[sti][i] );
  126.     color := color+1;
  127.       end;
  128.     end;
  129.   end; { octalcolor }
  130.  
  131.  
  132.  
  133. begin    { main procedure for octal indexing color table }
  134.   header;        { print the header }
  135.   lstringwrite(0,0,0,normal,'Color Table (Octal index) Mode');
  136.  
  137.   { left part 0-127 }
  138.   octalcolor(startcol,0,0);
  139.  
  140.   { right part for 128-256 }
  141.   octalcolor(startcol+15,2,128);
  142.   end; {demosoctal}
  143.  
  144.  
  145. {***** pressclear - press to exit }
  146. procedure pressclear;
  147. begin
  148.   lstringwrite(currentpage, msgrow, msgcol, intensity,'Press any key to exit');
  149.   while not inkey( lastch, lastscan) do ; { do nothing }
  150.   screen( currentmode );
  151. end;
  152.  
  153.  
  154.  
  155. {***** demosone -display all the character colors for the current mode }
  156. procedure demos;
  157. var numcolumn : integer;
  158. begin
  159.   currentmode := screenmode(currentpage, numcolumn);
  160.   demosoctal;            { color indexed by octal }
  161.   pressclear;            { prompt 'press any key to exit' }
  162.   demosdecimal;         { color indexed by decimal }
  163.   pressclear;
  164. end; {demos}
  165.  
  166.  
  167.  
  168. {***** procedure delayawhile - delay unless a key is pressed }
  169. { returns true if a key is pressed }
  170. { returns false if no key is pressed in the delay period }
  171. function delayawhile( delay : integer): boolean;
  172. var
  173.   count, i, x : integer;
  174. begin
  175.     delayawhile := false;
  176.     count := 0;
  177.     while not inkey( lastch, lastscan) do { delay unless a key is pressed}
  178.       if count >= delay then return      { no key is pressed }
  179.       else begin
  180.     for i := 1 to delay do    x := 1; { delay }
  181.     count := count +1;
  182.       end;
  183.     delayawhile := true;
  184. end; { delayawhile }
  185.  
  186.  
  187.  
  188.  
  189. {***** demosall - demo all the color text table }
  190. procedure demosall;
  191. var
  192.   numcolumn,  savemode : integer;
  193.  
  194.   {**** modecolor- demostrate all the color table for all the mode }
  195.   procedure modecolor( startmode, endmode : integer);
  196.   var  mode, color, palettenum : integer;
  197.   begin
  198.     for mode :=startmode to endmode do begin {for all the screen modes}
  199.       currentmode := mode;
  200.       demosoctal;                    { color indexed by octal }
  201.       lstringwrite(currentpage,msgrow,msgcol,intensity,
  202.      'Press any key to enter the Driver mode');
  203.       if currentmode = 1 then
  204.       begin        {25x40 color text mode. display all the boarder color}
  205.     for color := 0 to 31 do begin
  206.       boarder( color );
  207.       locate(currentpage, inforow, 0);
  208.       write('boarder(',color:3,' ) displaying boarder color');
  209.       if delayawhile(delay) then return;       { true if a key is pressed}
  210.     end;
  211.     lstringwrite(currentpage, inforow, 0, normal , blanks); {erase message}
  212.       end { currentmode = 1 }
  213.       else
  214.        if currentmode = 4 then    { 320x200 graphics mode. display all palettes }
  215.        begin
  216.      for palettenum := 0 to 1 do
  217.        for color := 0 to 15 do begin
  218.          palette( palettenum, color);      { palette and background color}
  219.          locate(currentpage, inforow, 0);
  220.          write('palette(',palettenum:3,',',color:3,' ) displaying');
  221.          if delayawhile(delay) then return;
  222.        end;
  223.     lstringwrite(currentpage, inforow, 0, normal , blanks); {erase message}
  224.     end   { currentmode = 4 }
  225.        else
  226.      if delayawhile(delay) then return;
  227.       demosdecimal;            { color indexed by decimal }
  228.       lstringwrite(currentpage,msgrow,msgcol,intensity,
  229.      'Press any key to enter the Driver mode');
  230.       if delayawhile(delay) then return;
  231.     end; { for }
  232.   end; { procedure modecolor }
  233.  
  234.  
  235. begin  { demosall }
  236.   { display color tables for all the modes }
  237.   currentmode := screenmode(currentpage, numcolumn);
  238.   savemode := currentmode;
  239.   if currentmode = 7
  240.   then
  241.     modecolor( 7, 7 )    { mode 7 to mode 7 }
  242.   else
  243.     modecolor(0, 6);    { mode 0 to 6 }
  244.   screen( savemode);    {restore screen mode }
  245.   currentmode := screenmode( currentpage, numcolumn);
  246.  end; { demosall }
  247.  
  248. begin
  249. end.
  250.